home *** CD-ROM | disk | FTP | other *** search
VERSION 5.00 Object = "{083C8784-F106-4CC2-9930-876218A6B74C}#1.1#0"; "ciaXPButton.ocx" Object = "{506637F7-8E95-462C-A587-891B4935F57D}#1.0#0"; "ciaXPPanel.ocx" Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form Form1 Caption = "Form1" ClientHeight = 7440 ClientLeft = 60 ClientTop = 450 ClientWidth = 10455 LinkTopic = "Form1" LockControls = -1 'True ScaleHeight = 7440 ScaleWidth = 10455 StartUpPosition = 3 'Windows Default Begin VB.PictureBox picICON Appearance = 0 'Flat AutoRedraw = -1 'True BackColor = &H80000005& BorderStyle = 0 'None ForeColor = &H80000008& Height = 240 Left = 10995 ScaleHeight = 16 ScaleMode = 3 'Pixel ScaleWidth = 16 TabIndex = 8 Top = 3090 Visible = 0 'False Width = 240 End Begin MSComctlLib.StatusBar StatusBar1 Align = 2 'Align Bottom Height = 375 Left = 0 TabIndex = 7 Top = 7065 Width = 10455 _ExtentX = 18441 _ExtentY = 661 _Version = 393216 BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} NumPanels = 1 BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} EndProperty EndProperty End Begin MSComctlLib.ListView ListView1 Height = 6585 Left = 3285 TabIndex = 6 Top = 540 Width = 7155 _ExtentX = 12621 _ExtentY = 11615 View = 3 LabelWrap = -1 'True HideSelection = -1 'True _Version = 393217 ForeColor = -2147483640 BackColor = -2147483643 BorderStyle = 1 Appearance = 1 NumItems = 0 End Begin ciaXPPanel.XPPanel XPPanel2 Align = 3 'Align Left Height = 6525 Left = 0 TabIndex = 1 Top = 540 Width = 3285 _ExtentX = 5794 _ExtentY = 11509 LicValid = -1 'True Begin MSComctlLib.TreeView TreeView1 Height = 6195 Left = 0 TabIndex = 2 Top = 345 Width = 3240 _ExtentX = 5715 _ExtentY = 10927 _Version = 393217 Indentation = 44 Style = 7 Appearance = 0 End Begin ciaXPButton.XPButton XPButton1 Height = 255 Left = 3015 TabIndex = 3 Top = 60 Width = 210 _ExtentX = 370 _ExtentY = 450 Caption = "X" ButtonStyle = 2 OriginalPicSizeW= 0 OriginalPicSizeH= 0 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BackStyle = 0 LicValid = -1 'True End End Begin ciaXPPanel.XPPanel XPPanel1 Align = 1 'Align Top Height = 540 Left = 0 TabIndex = 0 Top = 0 Width = 10455 _ExtentX = 18441 _ExtentY = 953 LicValid = -1 'True Begin ciaXPButton.XPButton XPButton2 Height = 480 Left = 60 TabIndex = 4 Top = 15 Width = 1080 _ExtentX = 1905 _ExtentY = 847 Caption = "Folders" ButtonStyle = 2 Picture = "Form1.frx":0000 PictureWidth = 22 PictureHeight = 20 PictureSize = 2 OriginalPicSizeW= 22 OriginalPicSizeH= 20 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Toggle = -1 'True MaskColor = 16711935 BackStyle = 0 LicValid = -1 'True End Begin ciaXPButton.XPButton XPButton3 Height = 480 Left = 1185 TabIndex = 5 Top = 15 Width = 660 _ExtentX = 1164 _ExtentY = 847 Caption = "" ButtonStyle = 2 Picture = "Form1.frx":05A2 PictureWidth = 23 PictureHeight = 19 PictureSize = 2 OriginalPicSizeW= 23 OriginalPicSizeH= 19 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BackStyle = 0 DropDown = -1 'True LicValid = -1 'True End End Begin MSComctlLib.ImageList ImageList2 Left = 10815 Top = 2460 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 12632256 _Version = 393216 BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} NumListImages = 2 BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":0B4C Key = "" EndProperty BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":4A56 Key = "" EndProperty EndProperty End Begin MSComctlLib.ImageList imgSMALL Left = 10815 Top = 1245 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 MaskColor = 16711935 _Version = 393216 End Begin MSComctlLib.ImageList ImageList1 Left = 10800 Top = 1830 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 16711935 _Version = 393216 BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} NumListImages = 17 BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":8208 Key = "hd" EndProperty BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":843A Key = "dt" EndProperty BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":878C Key = "ram" EndProperty BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":8B60 Key = "mc" EndProperty BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":8DF2 Key = "cl" EndProperty BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":CCFC Key = "cd" EndProperty BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":D04E Key = "rte" EndProperty BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":D3A2 Key = "f35" EndProperty BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":D6C4 Key = "op" EndProperty BeginProperty ListImage10 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":DA18 Key = "new" EndProperty BeginProperty ListImage11 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":DF74 Key = "cab" EndProperty BeginProperty ListImage12 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":E2C8 Key = "zip" EndProperty BeginProperty ListImage13 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":E61C Key = "rem" EndProperty BeginProperty ListImage14 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":E974 Key = "rar" EndProperty BeginProperty ListImage15 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":ECC8 Key = "md" EndProperty BeginProperty ListImage16 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":F01C Key = "ace" EndProperty BeginProperty ListImage17 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":F370 Key = "cp" EndProperty EndProperty End Attribute VB_Name = "Form1" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Enum LVHITTESTINFO_flags LVHT_ONITEMICON = &H2 LVHT_ONITEMLABEL = &H4 LVHT_ONITEMINDENT = &H8 LVHT_ONITEMBUTTON = &H10 LVHT_ONITEMRIGHT = &H20 LVHT_ONITEMSTATEICON = &H40 LVHT_ONITEM = (LVHT_ONITEMICON Or LVHT_ONITEMLABEL Or LVHT_ONITEMSTATEICON) ' user-defined LVHT_ONITEMLINE = (LVHT_ONITEM Or LVHT_ONITEMINDENT Or LVHT_ONITEMBUTTON Or LVHT_ONITEMRIGHT) End Enum Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LVHITTESTINFO pt As POINTAPI flags As LVHITTESTINFO_flags hitem As Long End Type Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Declare Function GetLogicalDrives Lib "kernel32" () As Long Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _ (ByVal pszPath As String, _ ByVal dwFileAttributes As Long, _ psfi As SHFILEINFO, _ ByVal cbSizeFileInfo As Long, _ ByVal uFlags As Long) As Long Private Const IMG_SIXTEEN = 16 Private Const IMG_THIRTYTWO = 32 Private Const IMG_ALREADYSET = 0 Private Const IMG_CUSTOM = 1 Private Const icon_FOLDER_CLOSED = 101 Private m_Path As String Private ArqExt As String Private WinDir As String Private SysDir As String Private TempDir As String Private SourcePath As String Private sFolder As String 'Private sFile As String Private sName As String Private sExtension As String Private sSize As String Private sType As String Private sModified As String Private sTime As String Private sCreated As String Private sAccessed As String Private sAttribute As String Private sMsDos As String Private sNone As String Private m_MyDocs As String Private m_hwnd As Long '------------------------------ Private Start As Long Private FvFilter As Variant Private IsFAT As Boolean Private InCab As Boolean Private InZip As Boolean Private Nodx As Node Private TypeNew() As FTs '------------------------------ Private WithEvents Archive As cArchive Attribute Archive.VB_VarHelpID = -1 '------------------------------ Const MyComputer$ = "MyComputer" Const Desktop$ = "Desktop" Private Const SHGFI_DISPLAYNAME = &H200 Const m_def_DragDropEnable = 0 Const m_def_FileFilter = "*.ace;*.cab;*.rar;*.zip" Const m_def_hWnd = 0 Const m_def_Path$ = "" Private m_DragDropEnable As Boolean Private m_FileFilter As String Private m_hwndTV As Long Private Sub AddImage(resICONVAL As Long, Optional imgSIZE As Long = IMG_ALREADYSET, Optional CustomHeight As Long = 16, Optional CustomWidth As Long = 16) On Error Resume Next With imgSMALL If imgSIZE <> IMG_ALREADYSET Then If imgSIZE <> IMG_CUSTOM Then .ImageHeight = imgSIZE .ImageWidth = imgSIZE Else .ImageHeight = CustomHeight .ImageWidth = CustomWidth End If End If .ListImages.Add , , LoadResPicture(resICONVAL, vbResBitmap) End With End Sub Private Sub ChangeImageSize(imgSIZE As Long, Optional CustomHeight As Long = 16, Optional CustomWidth As Long = 16) On Error Resume Next With imgSMALL If imgSIZE <> IMG_ALREADYSET Then If imgSIZE <> IMG_CUSTOM Then .ImageHeight = imgSIZE .ImageWidth = imgSIZE Else .ImageHeight = CustomHeight .ImageWidth = CustomHeight End If End If End With End Sub Private Sub SetPath(New_Path As String) While Right(New_Path, 1) = "\" New_Path = Left(New_Path, Len(New_Path) - 1) Wend If New_Path <> "" Then m_Path = New_Path Else XPListView1.ListItems.Clear End If End Sub Private Sub FillFiles() On Error GoTo ErrorFillFiles Dim obj As Scripting.FileSystemObject, f As Scripting.Folder, i As Scripting.File Dim sf As Scripting.Folder, itm As ListItem, iIMG As CICON, x As Long FreezeWindow ListView1.hwnd ListView1.ListItems.Clear ListView1.ColumnHeaders.Clear ListView1.ColumnHeaders.Add , , "Please wait...", 1440 ListView1.ListItems.Add , , "Loading..." FreezeWindow ListView1.Refresh DoEvents FreezeWindow ListView1.hwnd ListView1.ListItems.Clear ListView1.ColumnHeaders.Clear ListView1.ColumnHeaders.Add , , "NAME" ListView1.ColumnHeaders.Add , , "SIZE" ListView1.ColumnHeaders.Add , , "TYPE" ListView1.ColumnHeaders.Add , , "MODIFIED" Set ListView1.SmallIcons = Nothing imgSMALL.ListImages.Clear AddImage icon_FOLDER_CLOSED, IMG_SIXTEEN Set obj = New Scripting.FileSystemObject Set f = obj.GetFolder(m_Path) For Each i In f.Files Set iIMG = New CICON picICON.Picture = LoadPicture() iIMG.ExtractIconToHDC picICON.hdc, m_Path & "\" & i.Name Set iIMG = Nothing picICON.Picture = picICON.Image imgSMALL.ListImages.Add , , picICON.Picture picICON.Picture = LoadPicture() Next Set ListView1.SmallIcons = imgSMALL For Each sf In f.SubFolders Set itm = ListView1.ListItems.Add(, , sf.Name, , 1) itm.SubItems(2) = sf.Type itm.SubItems(3) = sf.DateLastModified itm.Tag = "FOLDER" Next x = 2 For Each i In f.Files Set itm = ListView1.ListItems.Add(, , i.Name, , x) x = x + 1 itm.SubItems(1) = i.Size itm.SubItems(2) = i.Type itm.SubItems(3) = i.DateLastModified itm.Tag = "FILE" Next FreezeWindow Exit Sub ErrorFillFiles: FreezeWindow MsgBox Err & ":Error in FillFiles. Error Message: " & Err.Description, vbCritical, "Warning" Exit Sub End Sub Private Function FreezeWindow(Optional mLNGhWnd As Long = 0) As Long On Error Resume Next Dim x As Long FreezeWindow = LockWindowUpdate(mLNGhWnd) End Function Private Sub Form_Activate() FillFiles End Sub Private Sub Form_Load() m_Path = "C:" InitializeTree Const Shell32$ = "Shell32.Dll" FvFilter = Split(LCase(m_FileFilter), ";") m_MyDocs = FolderLocation(CSIDL_PERSONAL) 'Get Win, Sys, & Temp directory paths WinDir = Left$(Buffer, GetWindowsDirectory(Buffer, MAX_PATH)) SysDir = Left$(Buffer, GetSystemDirectory(Buffer, MAX_PATH)) TempDir = Left$(Buffer, GetTempPath(MAX_PATH, Buffer)) sFolder = GetResourceStringFromFile(Shell32, 4131) '"(" & GetResourceStringFromFile(Shell32, 4131) & ")" sName = GetResourceStringFromFile(Shell32, 8976) sExtension = StrConv(ext_, vbProperCase) sSize = GetResourceStringFromFile(Shell32, 8978) sType = GetResourceStringFromFile(Shell32, 8979) sModified = GetResourceStringFromFile(Shell32, 8980) sTime = GetResourceStringFromFile("Intl.Cpl", 25) sCreated = GetResourceStringFromFile(Shell32, 8996) sAccessed = GetResourceStringFromFile(Shell32, 8997) sAttribute = GetResourceStringFromFile(Shell32, 8987) sMsDos = "MsDos 8.3" sNone = GetResourceStringFromFile(Shell32, 9808) Enumerate 'LVColumnHeaders ListView1.Visible = True ListView1.Refresh ReDim Preserve TypeNew(0) 'init array of Ext/Type/IconIdx End Sub Private Sub InitializeTree() TreeView1.ImageList = ImageList1 End Sub '******************************************************* TreeView Code ************************************************* Private Function BuildFullPath(ByVal Nod As Node) As String On Error GoTo PROC_ERR Dim iPos As Integer Dim sExt As String Dim MyPath As String Dim MyDocs2 As String MyPath = Nod.FullPath iPos = InStrRev(MyPath, ":") If iPos < 2 Then MyDocs2 = Mid(m_MyDocs, 4) BuildFullPath = Replace(MyPath, Desktop & "\" & MyDocs2, m_MyDocs) GoTo CheckExt End If MyPath = Mid$(MyPath, iPos - 1) 'Pick up drive letter iPos = InStr(MyPath, "\") If iPos > 1 Then BuildFullPath = Left$(MyPath, 2) & Mid$(MyPath, iPos) BuildFullPath = Left$(MyPath, 2) End If CheckExt: sExt = GetExt(Nod.Text) If sExt <> "" Then For iPos = 0 To UBound(FvFilter) If sExt = GetExt(FvFilter(iPos)) Then 'Match Exit Function End If Next End If BuildFullPath = QualifyPath(BuildFullPath) PROC_EXIT: Exit Function PROC_ERR: If ErrMsgBox("BuildFullPath") = vbRetry Then Resume Next End Function Private Sub ClearTree() TreeView1.Visible = False TreeView1.Nodes.Clear TreeView1.Visible = True End Sub Private Sub LoadTree() Const Shell32$ = "Shell32.Dll" On Error GoTo PROC_ERR 'Use API (MUCH faster than scripting) '------------------------------ Dim FirstFixed As Integer Dim MaxPwr As Integer Dim Pwr As Integer '------------------------------ Dim DrvBitMask As Long Dim DriveType As Long '------------------------------ Dim MyDrive As String Dim MyPic As String Dim MyKey As String '------------------------------ Dim nod1 As Node Dim si As SHFILEINFO Dim RC As RECT '------------------------------ TreeView1.ImageList = ImageList1 ' Initialize ImageList. m_hwndTV = TreeView1.hwnd ' Establish the distance in which auto-scrolling happens within ' the TreeView's client area (we need a root item for these calls) ' If TreeView_GetItemRect(m_hwndTV, TreeView_GetRoot(m_hwndTV), RC, True) Then ' m_cxyAutoScroll = (RC.Bottom - RC.Top) * 2 ' Else ' m_cxyAutoScroll = 32 ' End If ' Initialize the auto expand and auto scroll timers ' already set in design properties ' tmrAutoExpand.Enabled = False ' tmrAutoExpand.Interval = 1000 ' tmrAutoScroll.Enabled = False ' tmrAutoScroll.Interval = 100 ' Store thet distance the cursor moves to initiate dragging. ' m_szDrag.cx = GetSystemMetrics(SM_CXDRAG) ' m_szDrag.cy = GetSystemMetrics(SM_CYDRAG) 'Private Const DRIVE_UNKNOWN As Long = 0 'Private Const DRIVE_NO_ROOT_DIR As Long = 1 'Private Const DRIVE_REMOVABLE As Long = 2 'Private Const DRIVE_FIXED As Long = 3 'Private Const DRIVE_REMOTE As Long = 4 'Private Const DRIVE_CDROM As Long = 5 'Private Const DRIVE_RAMDISK As Long = 6 MyDrive = GetResourceStringFromFile(Shell32, 4162) 'Desktop Set nod1 = TreeView1.Nodes.Add(, , Desktop, MyDrive, "dt") '----- 'MyDrive = GetResourceStringFromFile(Shell32, 9100) 'My Documents m_MyDocs = FolderLocation(CSIDL_PERSONAL) Set nod1 = TreeView1.Nodes.Add(Desktop, tvwChild, QualifyPath(m_MyDocs), Mid(m_MyDocs, 4), "md") If hasSubDirectory(m_MyDocs) Then TreeView1.Nodes.Add nod1, tvwChild End If '----- Set nod1 = TreeView1.Nodes.Add(Desktop, tvwChild, "Ftp", "Ftp Client", "rte") '----- MyDrive = GetResourceStringFromFile(Shell32, 9216) 'My Computer Set nod1 = TreeView1.Nodes.Add(Desktop, tvwChild, MyComputer, MyDrive, "mc") '----- DrvBitMask = GetLogicalDrives() ' DrvBitMask is a bitmask representing ' available disk drives. Bit position 0 ' is drive A, bit position 2 is drive C, etc. ' If function fails, return value is zero. If DrvBitMask Then ' Get & search each available drive MaxPwr = Int(Log(DrvBitMask) / Log(2)) ' a little math... For Pwr = 0 To MaxPwr If 2 ^ Pwr And DrvBitMask Then MyDrive = Chr$(65 + Pwr) & ":\" DriveType = GetDriveType(MyDrive) Select Case DriveType Case 0, 1: MyPic = "dl" Case 2: If Pwr < 2 Then 'A or B (Diskette) MyPic = "f35" Else 'other Removable MyPic = "rem" End If Case 3: MyPic = "hd" Case 4: MyPic = "rte" Case 5: MyPic = "cd" Case 6: MyPic = "ram" End Select 'Get Drive DisplayName. SHGetFileInfo MyDrive, 0&, si, Len(si), SHGFI_DISPLAYNAME Set nod1 = TreeView1.Nodes.Add(MyComputer, tvwChild, MyDrive, si.szDisplayName, MyPic) If (FirstFixed = 0) And (DriveType = 3) Then FirstFixed = TreeView1.Nodes.Count End If TreeView1.Nodes.Add nod1, tvwChild End If Next End If 'Add Control Panel MyDrive = GetResourceStringFromFile(Shell32, 4161) Set nod1 = TreeView1.Nodes.Add(MyComputer, tvwChild, "ControlPanel", MyDrive, "cp") TreeView1.Nodes.Add nod1, tvwChild 'expand first fixed drive Set nod1 = TreeView1.Nodes(FirstFixed) nod1.Expanded = True nod1.EnsureVisible 'ensure first entry (Desktop) is visible Set nod1 = TreeView1.Nodes(1) 'Desktop nod1.EnsureVisible TreeView1.Refresh Set nod1 = Nothing PROC_EXIT: Exit Sub PROC_ERR: If ErrMsgBox("LoadTree6") = vbRetry Then Resume Next End Sub Private Sub SetNodeVisible() Dim L4 As Long, Nod As Node Dim sFullPath As String Dim qPath As String qPath = QualifyPath(m_Path) For L4 = 1 To TreeView1.Nodes.Count Set Nod = TreeView1.Nodes(L4) sFullPath = BuildFullPath(Nod) If StrComp(sFullPath, qPath, vbTextCompare) = 0 Then Nod.EnsureVisible Nod.Selected = True TreeView1.Refresh Exit For End If End Sub Private Sub Enumerate() ClearTree FvFilter = Split(m_FileFilter, ";") LoadTree End Sub Private Function FileExistsW32FD(sSource As String) As WIN32_FIND_DATA Dim hFile As Long 'Returns True in dwReserved1 if file exists as well as raw data in WIN32_FIND_DATA structure hFile = FindFirstFile(sSource, FileExistsW32FD) FileExistsW32FD.dwReserved1 = hFile <> INVALID_HANDLE_VALUE FindClose hFile End Function Private Sub EnumFilesUnder(ByVal n As Node) On Error GoTo PROC_ERR Dim sPath As String Dim sExt As String Dim hFind As Long, L4 As Long Dim oldPath As String Dim W32FD As WIN32_FIND_DATA Dim n2 As Node Dim FolderPic As String TreeView1.Visible = False oldPath = "" sPath = BuildFullPath(n) & "*.*" 'old sPath = ucase$(n.FullPath & "\*.*") hFind = FindFirstFile(sPath, W32FD) ' Get the filename, if any. sPath = StripNull(W32FD.cFileName) If Len(sPath) = 0 Or StrComp(sPath, oldPath) = 0 Then ' Nothing found? Exit Do ElseIf Asc(sPath) <> 46 Then 'do we have a folder? If (W32FD.dwFileAttributes And vbDirectory) Then 'Yes FolderPic = "cl" Set n2 = TreeView1.Nodes.Add(n, tvwChild, , sPath, FolderPic) n2.ExpandedImage = "op" 'causes duplicate keys in My Documents n2.Key = BuildFullPath(n2) ' Add a dummy item so the + sign is displayed If hasSubDirectory(BuildFullPath(n) & sPath & "\") Then TreeView1.Nodes.Add n2, tvwChild End If Else 'do we have a matching file? sExt = GetExt(sPath) For L4 = 0 To UBound(FvFilter) If sPath Like FvFilter(L4) Then 'Yes Select Case sExt Case "zip", "cab", "ace", "rar" FolderPic = sExt Case Else FolderPic = "new" End Select Set n2 = TreeView1.Nodes.Add(n, tvwChild, , sPath, FolderPic) 'n2.Key = BuildFullPath(n2) ' TV.Nodes.Item(TV.Nodes.Count).Bold = True '***Node colors don't work if you are using background (wallpaper) in Treeview TreeView1.Nodes.Item(TreeView1.Nodes.Count).BackColor = vbBlue '&H98CCD0 '&HE0E0E0 'grey TreeView1.Nodes.Item(TreeView1.Nodes.Count).ForeColor = vbWhite 'RGB(248, 240, 136) 'Tree ylw Exit For End If Next End If End If FindNextFile hFind, W32FD oldPath = sPath FindClose hFind TreeView1.Visible = True Exit Sub PROC_EXIT: Exit Sub PROC_ERR: If ErrMsgBox("EnumFilesUnder") = vbRetry Then Resume Next End Sub Private Function GetExt(ByVal Name As String) As String On Error GoTo PROC_ERR Dim J As Integer J = InStrRev(Name, ".") If J > 0 And J < Len(Name) Then GetExt = LCase$(Mid$(Name, J + 1)) End If PROC_EXIT: Exit Function PROC_ERR: If ErrMsgBox("GetExt") = vbRetry Then Resume Next End Function Private Function hasSubDirectory(ByVal sPath As String) As Boolean On Error GoTo PROC_ERR Dim hFind As Long Dim oldPath As String Dim W32FD As WIN32_FIND_DATA Dim L4 As Long oldPath = "" hFind = FindFirstFile(sPath & "*.*", W32FD) ' Get the filename, if any. sPath = StripNull(W32FD.cFileName) If Len(sPath) = 0 Or StrComp(sPath, oldPath) = 0 Then ' Nothing found? Exit Do ElseIf Asc(sPath) <> 46 Then ' return true if we have found a directory under this path If (W32FD.dwFileAttributes And vbDirectory) Then hasSubDirectory = True Exit Do End If For L4 = 0 To UBound(FvFilter) If sPath Like FvFilter(L4) Then hasSubDirectory = True Exit Do End If Next End If FindNextFile hFind, W32FD oldPath = sPath FindClose hFind PROC_EXIT: Exit Function PROC_ERR: If ErrMsgBox("hasSubDirectory") = vbRetry Then Resume Next End Function Private Sub LoadFiles(ByVal Path As String) On Error GoTo ProcedureError Dim Win32Fd As WIN32_FIND_DATA Dim lHandle As Long Dim Item As ListItem Dim MyName As String Dim sExt As String Dim MyDate As Date Dim MySize As Currency Dim MyIcon As Long Dim Start As Long Dim MyCount As Long Const MustGet$ = "exe|ico|lnk|pif|cur" Start = GetTickCount() Screen.MousePointer = vbHourglass InZip = False SourcePath = QualifyPath(Path) 'LVColumnHeaders 'IsFAT = CheckFAT lHandle = FindFirstFile(SourcePath & "*.*", Win32Fd) If lHandle > 0 Then End If FindClose lHandle 'LoadCleanup 3 'ShowProgress Start, MyCount, Path ProcedureExit: Exit Sub ProcedureError: If ErrMsgBox(Me.Name & ".LoadFiles") = vbRetry Then Resume Next End Sub Private Sub ShowProgress(Start, Count, Path) Me.Caption = Format((GetTickCount() - Start) / 1000, "#,##0.00") & " seconds, " & Count & " Objects in " & Path End Sub Private Function GetFileType(ByVal sExt As String, ByVal FullPath As String, ByRef MyIcon As Long) As String On Error GoTo ProcedureError Dim sName As String Dim lRegKey As Long, L4 As Long If sExt <> "" Then 'NOTE: Array must be sorted for binary search L4 = BinarySearchTypeNew(sExt) If L4 <> -1 Then GetFileType = TypeNew(L4).Type MyIcon = TypeNew(L4).IconIndex Exit Function End If 'Not a duplicate so get info from registry If RegOpenKey(HKEY_CLASSES_ROOT, ByVal "." & sExt, lRegKey) = 0 Then 'Get type of file (Not to be confused with actual FileType ) RegQueryValueEx lRegKey, ByVal "", 0&, 1, ByVal Buffer, MAX_PATH sName = StripNull(Buffer) RegCloseKey lRegKey If Len(sName) Then 'Get FileType If RegOpenKey(HKEY_CLASSES_ROOT, sName, lRegKey) = 0 Then RegQueryValueEx lRegKey, ByVal "", 0&, 1, ByVal f_Type, 80 GetFileType = StripNull(f_Type) RegCloseKey lRegKey End If End If End If 'Bump array and add new extension/type L4 = UBound(TypeNew()) + 1 ReDim Preserve TypeNew(L4) TypeNew(L4).Ext = sExt If GetFileType = "" Then 'No associated type GetFileType = sNone 'was sFile & " " & UCase$(sExt) TypeNew(L4).IconIndex = 0 Else 'New Ext, get this Icon SHGetFileInfo FullPath, 0&, SFI, cbSFI, SMALLSYS_SHGFI_FLAGS TypeNew(L4).IconIndex = SFI.iIcon 'index in system imagelist End If TypeNew(L4).Type = GetFileType MyIcon = TypeNew(L4).IconIndex ShellSortTypeNewArray 'So we can use a binary search End If ProcedureExit: Exit Function ProcedureError: If ErrMsgBox(Me.Name & ".GetFileType") = vbRetry Then Resume Next End Function Private Sub ListView1_DblClick() On Error Resume Next Dim pt As POINTAPI Dim itm As ListItem GetCursorPos pt Set itm = ListView1.HitTest(pt.x, pt.y) If itm.Tag = "FOLDER" Then 'itFOLDER Then ' m_Path = SetPath(m_Path) & "\" & itm.Text m_Path = m_Path & "\" & itm.Text Debug.Print "m_Path = " & m_Path & "| itm.Text = " & itm.Text FillFiles End If Set itm = Nothing End Sub '**************************************************** TREEVIEW EVENTS ********************************************* Private Sub TreeView1_Expand(ByVal Node As MSComctlLib.Node) ' RaiseEvent Expand(Node) On Error GoTo PROC_ERR Screen.MousePointer = vbHourglass If Node.Children = 1 And Node.Child.Children <= 0 Then ' Remove the "dummy" item TreeView1.Nodes.Remove Node.Child.Index ' Enumerate file system items under this node Node.Sorted = False EnumFilesUnder Node Node.Sorted = True End If Screen.MousePointer = vbDefault PROC_EXIT: Exit Sub PROC_ERR: If ErrMsgBox("TV_Expand") = vbRetry Then Resume Next End Sub Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node) On Error GoTo FolderView1_NodeClick_Err Dim Path As String, sExt As String Dim Start As Long Set Nodx = Node ReDim Preserve TypeNew(0) Select Case Node.Key Case "Ftp" ListView1.ListItems.Clear Case "Desktop" LoadFiles QualifyPath(FolderLocation(CSIDL_DESKTOP)) Case "MyComputer" Case "MyDocuments" LoadFiles QualifyPath(FolderLocation(CSIDL_PERSONAL)) Case "ControlPanel" Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus Case Else Path = BuildFullPath(Node) sExt = GetExt(Node.Text) Start = GetTickCount() ' ShowTip = True Select Case sExt Case ace_, cab_, rar_, zip_ SourcePath = Path InZip = True ' Tip.MouseNotify FolderView1.hwnd, tipMouseMove 'LoadStart Screen.MousePointer = vbHourglass ' LVColumnHeaders Set Archive = New cArchive Archive.ArchiveName = Path Archive.ArchiveExt = sExt Archive.GetInfo ' LoadCleanup 1 Me.Caption = Path Case Else SourcePath = QualifyPath(Path) ' Tip.MouseNotify TreeView1.hwnd, tipMouseMove LoadFiles (QualifyPath(Path)) End Select End Select Exit Sub FolderView1_NodeClick_Err: Screen.MousePointer = vbDefault Select Case ErrMsgBox("FolderviewDemo.frmFolderviewDemo.FolderView1_NodeClick") Case vbAbort Exit Sub Case vbRetry Resume Case vbIgnore Resume Next End Select End Sub 
(.txt)